home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 050 / colordem.pqs / COLORDEM.PAS
Pascal/Delphi Source File  |  1984-12-18  |  13KB  |  342 lines
  1. {DEMO PROGRAM TO SHOW THE COLOR GRAPHICS CAPABILITIES OF THESE PROCEDURES.
  2. THIS PROGRAM ASSUMES STARTING IN 80 X 25 ALPHANUMERIC MODE ON THE COLOR
  3. DISPLAY. I SUGGEST YOU DOWNLOAD THE ENTIRE PROGRAM AS ONE PIECE AND GET IT
  4. WORKING AND THEN CHANGE ONE PART AT A TIME TO UNDERSTAND HOW IT WORKS}
  5.  
  6. { Pset -- set point at x-y to a color
  7.   Linedraw -- draw a line from x-y to x-y
  8.   Boxdraw -- draw a box by giving opposite corner coordinates
  9.   screen -- select screen type much like basic screen command
  10.   color -- select background color and pallete                  }
  11.  
  12. PROGRAM COLOR_DEMO;
  13. var
  14.     i,k        :  integer;
  15.     x,y        :  integer;
  16.     row        :  integer;
  17.     col        :  integer;
  18.  
  19. {=======================================================================}
  20. procedure screen(sel : integer);
  21. {=======================================================================}
  22. {PROC TO SET SCREEN TO 320 X 200 COLOR OR 80 X 25 ALPHANUMERIC COLOR.   }
  23. {SCREEN(0) = GRAPHICS 320 X 200                                         }
  24. {SCREEN(1) = ALPHANUMERIC 80 X 25                                       }
  25. {                                                                       }
  26. {=======================================================================}
  27.  
  28. type Regpack = record
  29.                  AX, BX, CX, DX, BP, SI, DI, DS, ES, FLAGS: Integer;
  30.                end;
  31.  
  32. var Registers  :  Regpack;
  33.     AL, AH     :  byte;
  34.  
  35. begin
  36.   if sel = 0 then
  37.   begin
  38.     Registers.AX := $0003;  {use standard bios calls to set the graphics}
  39.     Intr($10, Registers);   {adapter }
  40.   end;
  41.   if sel = 1 then
  42.   begin
  43.     Registers.AX := $0004;
  44.     Intr($10, Registers);
  45.   end;
  46. end;
  47.  
  48. {=======================================================================}
  49. procedure color(backg , palette : integer);
  50. {=======================================================================}
  51. {PROC TO SET COLOR OF BACKGROUND AND PALETTE                            }
  52. {WORKS LIKE BASIC GRAPHICS COLOR STATEMENT                              }
  53. {                                                                       }
  54. {=======================================================================}
  55.  
  56. var t1, t2     :  integer;
  57.  
  58. begin
  59.   t1 := palette shl 5;       {shift 0 or 1 into proper bit}
  60.   t1 := t1 and $0020;        {mask out any other bits}
  61.   t2 := backg and $000F;     {mask out all but background color select bits}
  62.   port[$03D9] := t1 or t2;   {put the 2 together and send to the color select}
  63. end;                         {register on the color board}
  64. {=======================================================================}
  65. procedure rowoff(r : integer; var mo,ro :integer);
  66. {=======================================================================}
  67. {PROC TO FIND MAJOR MEMORY OFFSET AND ROW OFFSET -- A SUBROUTINE        }
  68. {USED BY PSET                                                           }
  69. {                                                                       }
  70. {=======================================================================}
  71.  
  72. var
  73.  
  74. t1,t2          : integer;
  75.  
  76. begin
  77.   t1 := r and $01;        {find major offset from row input}
  78.   if t1 = 1 then mo := $2000 else mo := $0000;
  79.   t2 := r shr 1;          {find row offset}
  80.   ro := t2 * 80;
  81. end;
  82.  
  83. {=======================================================================}
  84. procedure coloff(c : integer; var co,dn :integer);
  85. {=======================================================================}
  86. {PROC TO FIND BYTE OFFSET WITHIN ROW AND DOT WITHIN BYTE -- A SUBROUTINE}
  87. {USED BY PSET                                                           }
  88. {                                                                       }
  89. {=======================================================================}
  90.  
  91. begin
  92.   co := c shr 2;    {find byte within column}
  93.   dn := c and $03;  {find dot number within byte}
  94. end;
  95.  
  96. {=======================================================================}
  97. procedure dot_color(var dt0,dt1,dt2,dt3 : integer ;cn : integer);
  98. {=======================================================================}
  99. {PROC TO SET DOT WITHIN BYTE TO THE CORRECT COLOR -- A SUBROUTINE       }
  100. {USED BY PSET                                                           }
  101. {                                                                       }
  102. {=======================================================================}
  103.  
  104. begin
  105.     case cn of
  106.     0  :  begin           {set correct bit pattern for correct dot and color}
  107.             dt0 := $0000;
  108.             dt1 := $0000;
  109.             dt2 := $0000;
  110.             dt3 := $0000;
  111.           end;
  112.     1  :  begin
  113.             dt0 := $0040;
  114.             dt1 := $0010;
  115.             dt2 := $0004;
  116.             dt3 := $0001;
  117.           end;
  118.     2  :  begin
  119.             dt0 := $0080;
  120.             dt1 := $0020;
  121.             dt2 := $0008;
  122.             dt3 := $0002;
  123.           end;
  124.     3  :  begin
  125.             dt0 := $00C0;
  126.             dt1 := $0030;
  127.             dt2 := $000C;
  128.             dt3 := $0003;
  129.           end;
  130.   end;
  131. end;
  132.  
  133. {=======================================================================}
  134. procedure pset(set_col,set_row,color_no : integer);
  135. {=======================================================================}
  136. {PROC TO SET A POINT AT COL AND ROW (OR X AND Y IF YOU PREFER) COORD-   }
  137. {INATES.                                                                }
  138. {WORKS LIKE BASIC PSET STATEMENT                                        }
  139. {                                                                       }
  140. {=======================================================================}
  141.  
  142. const
  143.   VideoSeg: Integer   = $0B800;
  144.  
  145. var
  146.     major_offset  :  integer;
  147.     row_offset    :  integer;
  148.     col_offset    :  integer;
  149.     dot_no        :  integer;
  150.     membyte       :  integer;
  151.     temp          :  integer;
  152.     d0            :  integer;
  153.     d1            :  integer;
  154.     d2            :  integer;
  155.     d3            :  integer;
  156.     cn            :  integer;
  157.  
  158. begin { main code of pset proc }
  159.   rowoff(set_row,major_offset,row_offset);
  160.   coloff(set_col,col_offset,dot_no);
  161.   dot_color(d0,d1,d2,d3,color_no);
  162.   membyte := Mem[videoseg : major_offset + col_offset + row_offset];
  163.   {get byte to be changed}
  164.   {pull information from byte that was there, masking bits that}
  165.   {will be changed to zero, then set bits to be changed to proper color}
  166.     case dot_no of
  167.     0  :  begin
  168.             temp := membyte and (not $C0);
  169.             membyte := temp or d0;
  170.           end;
  171.     1  :  begin
  172.             temp := membyte and (not $30);
  173.             membyte := temp or d1;
  174.           end;
  175.     2  :  begin
  176.             temp := membyte and (not $0C);
  177.             membyte := temp or d2;
  178.           end;
  179.     3  :  begin
  180.             temp := membyte and (not $03);
  181.             membyte := temp or d3;
  182.           end;
  183.   end;
  184.   Mem[videoseg : major_offset + col_offset + row_offset] := membyte;
  185.   {put changed byte back}
  186. end;
  187.  
  188. {=======================================================================}
  189. Procedure Drawline(FromX,FromY,ToX,ToY,color_no:Integer);
  190. {=======================================================================}
  191. {PROC TO DRAW A LINE FROM X-Y COORDINATE TO A 2ND X-Y COORDINATE        }
  192. {THIS PROC WAS WRITTEN BY ALEX MARTINELLI FROM ROME                     }
  193. {                                                                       }
  194. {=======================================================================}
  195. { note all coords assumed to be in proper ranges - no checks done !}
  196.  
  197. var temp,Dx, Dy, XIncBefore, XIncAfter, YIncBefore, YIncAfter : Integer;
  198.     Curpoint, Accumul : Integer;
  199.  
  200. begin {drawline}
  201.   { set 'standard values' for increments assuming line inclination
  202.      is between 0 and 45 degrees }
  203.   XIncBefore := 1 ; XIncAfter := 0 ;
  204.   YincBefore := 0 ; YIncAfter := 1 ;
  205.   { correct for negative slopes, if any }
  206.   Dx := ToX - FromX;
  207.   if Dx<0 then begin
  208.     Dx := abs(Dx);
  209.     XIncBefore := -1 ;
  210.   end {if};
  211.   Dy := ToY - FromY;
  212.   if Dy<0 then begin
  213.     Dy := abs(Dy);
  214.     YIncAfter := -1 ;
  215.   end {if};
  216.   { correct for line closer to vertical than to horizontal, if needed }
  217.   if Dx<Dy then begin
  218.     { swap Dx and Dy }
  219.     Temp := Dx ;
  220.     Dx := Dy ;
  221.     Dy := Temp ;
  222.     { swap 'before' and 'after' status for increments }
  223.     XIncAfter := XIncBefore ; XIncBefore := 0;
  224.     YIncBefore := YIncAfter ; YIncAfter := 0;
  225.   end{if};
  226.   { now: Dx is total number of points to plot;
  227.           Dy is increment of the shorter axis per each Dx of increment
  228.              along the longer axis. }
  229.   Accumul := Dx div 2 ;
  230.   for Curpoint := 1 to Dx do begin
  231.     pset(FromX,FromY,color_no);
  232.     FromX := FromX + XIncBefore ;
  233.     FromY := FromY + YIncBefore ;
  234.     Accumul := Accumul + Dy ;
  235.     if Accumul > Dx then begin
  236.       Accumul := Accumul - Dx ;
  237.       FromX := FromX + XIncAfter ;
  238.       FromY := FromY + YIncAfter ;
  239.     end{if};
  240.   end{for};
  241. end {Procedure Drawline};
  242.  
  243. {=======================================================================}
  244. Procedure Drawbox(fx,fy,tx,ty,colr_no:Integer);
  245. {=======================================================================}
  246. {PROC TO DRAW BOX -- FX AND FY ARE FROM X FROM Y UPPER LEFT CORNER AND  }
  247. {TX AND TY ARE TO X AND TO Y LOWER RIGHT CORNER -- THIS WORKS SIMILAR   }
  248. {TO THE LINE COMMAND IN BASIC WITH THE BOX OPTION                       }
  249. {                                                                       }
  250. {=======================================================================}
  251.  
  252. begin
  253. Drawline(fx,fy,tx,fy,colr_no);   {top horizontal}
  254. Drawline(tx,fy,tx,ty,colr_no);   {right vertical}
  255. Drawline(tx,ty,fx,ty,colr_no);   {bottom horizontal}
  256. Drawline(fx,ty,fx,fy,colr_no);   {left vertical}
  257. end;
  258. {=======================================================================}
  259. {START OF DEMO PROGRAM MAIN CODE                                        }
  260. { 1) DRAW COLORBARS USING PSET PROCEDURE                                }
  261. { 2) DRAW VARIOUS LENGTH LINES USING LINE PROCEDURE                     }
  262. { 3) DRAW VARIOUS SIZE BOXES USING BOX DRAW PROCEDURE -- ALSO USE       }
  263. {    WRITELN TO SHOW X - Y COORDINATES AS THE BOXES ARE DRAWN           }
  264. {                                                                       }
  265. {=======================================================================}
  266.  
  267. begin
  268.   row := 0;
  269.   col := 1;
  270.   x := 0;
  271.   y := 199;
  272. { start of colorbar demo }
  273.   screen(1);                  {set graphics mode}
  274.   color(0,0);                 {set background color 0, pallette 0 }
  275.   gotoxy(10,23);
  276.   writeln('COLOR BAR DEMO');
  277.   for row := 0 to 100 do      {draw colorbars using pset}
  278.   begin
  279.     for col := 0 to 20 do
  280.     pset(col,row,0);
  281.     for col := 21 to 40 do
  282.     pset(col,row,1);
  283.     for col := 41 to 60 do
  284.     pset(col,row,2);
  285.     for col := 61 to 80 do
  286.     pset(col,row,3);
  287.   end;
  288.   gotoxy(10,24);
  289.   writeln('HIT RETURN TO CONTINUE');
  290.   read;
  291.   { start of line draw demo }
  292.   screen(1);                  {set graphics mode again to erase the screen}
  293.   color(7,1);                 {change background color and pallete selection}
  294.   gotoxy(10,23);
  295.   writeln('LINE DRAW DEMO');
  296.   i := 0;
  297.   repeat
  298.   Drawline(0,0,319,I,2);      {draw lines with drawline proc}
  299.   i := i + 10;
  300.   until i >= 199;
  301.   gotoxy(10,24);
  302.   writeln('HIT RETURN TO CONTINUE');
  303.   read;
  304.   { start of box draw demo }
  305.   screen(1);                  {set graphics mode again to erase the screen}
  306.   color(0,0);                 {change background color and pallete selection}
  307.   gotoxy(28,21);
  308.   writeln('BOX DRAW DEMO');
  309.   gotoxy(28,7);
  310.   writeln('X - Y');           {this is to continually show x-y coordinates}
  311.   gotoxy(28,8);               {as program draws boxes}
  312.   writeln('COORDINATES');
  313.   for k := 1 to 26 do
  314.   begin
  315.     gotoxy(28,10);
  316.     writeln('X is ',x:3);
  317.     gotoxy(28,11);
  318.     writeln('Y is ',y:3);
  319.     Drawbox(x,x,y,y,2);
  320.     x := x + 4;
  321.     y := y - 4;
  322.   end;
  323.   x := x - 2;
  324.   y := y + 2;
  325.   for k := 1 to 26 do
  326.   begin
  327.     gotoxy(28,10);
  328.     writeln('X is ',x:3);
  329.     gotoxy(28,11);
  330.     writeln('Y is ',y:3);
  331.     Drawbox(x,x,y,y,1);
  332.     x := x - 4;
  333.     y := y + 4;
  334.   end;
  335.   gotoxy(28,23);
  336.   writeln('HIT RETURN');
  337.   gotoxy(28,24);
  338.   writeln('TO CONTINUE');
  339.   read;
  340.   screen(0);        {go back to alphanumeric mode to use turbo editor}
  341. end.
  342.